home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / check-menu-item.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  6.9 KB  |  172 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;check-menu.lisp
  3. ;;
  4. ;; Copyright © 1992 University of Toronto, Department of Computer Science
  5. ;; All Rights Reserved
  6. ;;
  7. ;; author: Mark A. Tapia
  8. ;;
  9. ;;  Methods to support a new class of menus-items check-mark-menu-items.
  10. ;;  A check-mark-menu-item remembers the check-mark character
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (in-package menus)
  14. (provide :check-menus)
  15.  
  16. (export '(check-menu-item check-window-menu-item
  17.           set-menu-item-check-mark set-check-mark-char
  18.           containing-view)
  19.         :menus)
  20.  
  21. #|
  22. This file extends menus items to check-menu-items
  23.  
  24. Check-menu-items                        ; a subclass of menu-items
  25. Check-menu-items store the check mark associated with them. The mark can
  26. be specified in three ways:
  27.   1. by specifying the mark when initializing the instance.
  28.        (make-instance 'check-menu-item :mark #\CheckMark)
  29.        which is equivalent to (make-instance 'check-menu-item :mark t)
  30.   2. by the set-check-mark-char method specifying a mark that is not t or nil. 
  31.         (set-check-mark-char check-menu-item mark) 
  32.   3. by the set-menu-item-check-mark method specifying a mark that
  33.      is not t or nil.
  34.         (set-check-menu-item-check-mark check-menu-item mark)
  35.      (set-menu-item-check-mark check-menu-item t) uses the previously
  36.      specified check mark.
  37.  
  38.   Methods 1-2 do not check the item. Method 3 changes the character and checks
  39.   the item.
  40.  
  41.   Use the initarg :mark to set the character (default #\checkMark)
  42.   Use (set-check-mark char menu-item char) to set the character
  43.   or  (set-menu-item-check-mark menu-item char) where char is not t or nil
  44.  
  45. check-menu-item                         ; a menu-item
  46.   :initarg :mark                        ; default #\CheckMark
  47.      specifies the character to be used as the marking character for
  48.      the menu item.
  49.  
  50.      Mark may be t, a character, the character code of the character,
  51.      or a string whose first character will be the checkmark character.
  52.      Specifying any other value, uses the default #\CheckMark character
  53.  
  54.      The default mark is correctly printed when using the standard
  55.      menu-font of Chicago but not with other fonts.
  56.  
  57.    Each of the menu-items created by the following instances specify
  58.    the standard Chicago font checkmark character:
  59.      (make-instance 'check-menu-item)
  60.      (make-instance 'check-menu-item :mark t)
  61.      (make-instance 'check-menu-item :mark #\CheckMark)
  62.      (make-instance 'check-menu-item :mark "")   ; the font is Chicago
  63.      (make-instance 'check-menu-item :mark 18)
  64.  
  65. check-window-menu-item                         ; a window-menu-item
  66.     See check-menu-item
  67.  
  68.  
  69. Methods of interest
  70.      (set-check-mark-char check-menu-item mark)
  71.           sets the check mark character for the menu-item
  72.           The mark may be
  73.           1.  a character
  74.           2.  an integer (0 - 255), where (code-char mark) is the character
  75.           3.  a string, the first character of which is the marking character
  76.  
  77.      (set-menu-item-check-mark check-menu-item t)
  78.           checks the item, using the mark associated with the menu-item
  79.  
  80.      (set-menu-item-check-mark check-menu-item nil)
  81.           unchecks the item, but remembers the mark associated with a check
  82.  
  83.      (set-menu-item-check-mark check-menu-item mark)
  84.          sets the mark (in one of the forms 1-3 above) and checks the menu-item
  85.  
  86. Do-menu-item-action
  87. Performs the menu item action associated with the menu item.
  88.  
  89. (do-menu-item-action check-menu-item)
  90.     First checks or unchecks the item, removing/adding the check-mark.
  91.     Then invokes the menu-item-action-function associated with the
  92.     check-menu-item with no parameters.
  93.  
  94. (do-menu-item-action window-menu-item)
  95.     First checks or unchecks the item, removing/adding the check-mark.
  96.     Then, invokes the menu-item-action-function associated with the 
  97.     check-menu-item with one parameter - the window-menu-item.
  98.  
  99.  
  100. |#
  101.  
  102. (defclass check-menu-item (menu-item)
  103.   ((check-mark-char :initarg :mark))
  104.   (:default-initargs :mark #\CheckMark))
  105.  
  106. (defclass check-window-menu-item (window-menu-item check-menu-item) ())
  107.   
  108. (defmethod containing-view ((menu-item check-menu-item))
  109.   ;; find the root of the chain of hier-marking menus
  110.   (let ((owner (slot-value menu-item 'ccl::owner)))
  111.     (if owner (containing-view owner) menu-item)))
  112.  
  113. (defmethod containing-view ((menu-item check-menu-item))
  114.   ;; find the root of the chain of hier-marking menus
  115.   (let ((owner (menu-item-owner menu-item)))
  116.     (if owner (containing-view owner) menu-item)))
  117.  
  118. ;; specialize this to take other actions after checking a menu item
  119.  
  120. (defmethod initialize-instance ((menu-item check-menu-item) &rest initargs)
  121.   (apply #'call-next-method menu-item initargs)
  122.   (with-slots (check-mark-char) menu-item
  123.       (set-check-mark-char menu-item check-mark-char)))
  124.  
  125. (defmethod do-menu-item-action ((menu-item check-menu-item) &optional param)
  126.   (declare (ignore param))
  127.   (let ((menu-item-action (menu-item-action-function menu-item)))
  128.     (set-menu-item-check-mark menu-item
  129.                               (if (menu-item-check-mark menu-item)
  130.                                 nil
  131.                                 (slot-value menu-item 'check-mark-char)))
  132.     (when menu-item-action (funcall menu-item-action))))
  133.  
  134.  
  135.  
  136. (defmethod do-menu-item-action ((menu-item check-window-menu-item) &optional param)
  137.   (let ((menu-item-action (menu-item-action-function menu-item)))
  138.     (set-menu-item-check-mark menu-item
  139.                               (if (menu-item-check-mark menu-item)
  140.                                 nil
  141.                                 (slot-value menu-item 'check-mark-char)))
  142.     (when menu-item-action (funcall menu-item-action param))))
  143.  
  144. (defmethod set-menu-item-check-mark ((menu-item check-menu-item) mark)
  145.   ;; uncheck the item if mark is nil
  146.   ;; check the item if mark is not nil
  147.   ;;    if mark is not t, set the character
  148.   ;;    otherwise use the check-mark-char associated with the item.
  149.   (with-slots (check-mark-char) menu-item
  150.   (cond ((equal mark t)
  151.          (call-next-method menu-item check-mark-char))
  152.         ((null mark)
  153.          (call-next-method menu-item nil))
  154.         (t (set-check-mark-char menu-item mark)
  155.            (call-next-method menu-item check-mark-char)))))
  156.  
  157. (defmethod set-check-mark-char ((menu-item check-menu-item) mark)
  158.   ;; Set the mark associated with a check mark for a menu item
  159.   ;; When mark is 
  160.   ;;     a character, set the check mark char to the character
  161.   ;;     an integer (0 - 255), set the char to the character with the integer code
  162.   ;;     a string, set the mark to the first character of the string    
  163.   ;;     otherwise set the mark to #\checkMark
  164.   (let ((type (type-of mark)))
  165.     (setf (slot-value menu-item 'check-mark-char) 
  166.           (cond ((stringp mark) (char mark 0))
  167.                 ((equal type 'character) mark)
  168.                 ((equal type 'standard-char) mark)
  169.                 ((and (equal type 'fixnum) (<= 0 mark 255))
  170.                  (code-char mark))
  171.                 (t #\CheckMark)))))
  172.